home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / utils / highlight-headers.el.z / highlight-headers.el
Encoding:
Text File  |  1998-05-21  |  20.1 KB  |  590 lines
  1. ;;; highlight-headers.el --- highlighting message headers.
  2.  
  3. ;; Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
  4. ;; Copyright (C) 1995 Tinker Systems
  5.  
  6. ;; Keywords: mail, news
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Synched up with: Not in FSF.
  26.  
  27. ;; This code is shared by RMAIL and VM.
  28. ;;
  29. ;; Faces:
  30. ;;
  31. ;; message-headers            the part before the colon
  32. ;; message-header-contents        the part after the colon
  33. ;; message-highlighted-header-contents    contents of "special" headers
  34. ;; message-cited-text            quoted text from other messages
  35. ;;
  36. ;; Variables:
  37. ;;
  38. ;; highlight-headers-regexp            what makes a "special" header
  39. ;; highlight-headers-citation-regexp        matches lines of quoted text
  40. ;; highlight-headers-citation-header-regexp    matches headers for quoted text
  41.  
  42. (defgroup highlight-headers nil
  43.   "Fancify rfc822 documents."
  44.   :group 'mail
  45.   :group 'news)
  46.  
  47. (defgroup highlight-headers-faces nil
  48.   "Faces of highlighted headers."
  49.   :group 'highlight-headers
  50.   :group 'faces)
  51.  
  52. (defface message-headers '((t (:bold t)))
  53.   "Face used for header part before colon."
  54.   :group 'highlight-headers-faces)
  55.  
  56. (defface message-header-contents '((t (:italic t)))
  57.   "Face used for header part after colon."
  58.   :group 'highlight-headers-faces)
  59.  
  60. (defface message-highlighted-header-contents '((t (:italic t :bold t)))
  61.   "Face used for contents of \"special\" headers."
  62.   :group 'highlight-headers-faces)
  63.  
  64. (defface message-cited-text '((t (:italic t)))
  65.   "Face used for cited text."
  66.   :group 'highlight-headers-faces)
  67.  
  68. (defface x-face '((t (:background "white" :foreground "black")))
  69.   "Face used for X-Face icon."
  70.   :group 'highlight-headers-faces)
  71.  
  72. ;;(condition-case nil
  73. ;;    (face-name 'message-addresses)
  74. ;;  (wrong-type-argument
  75. ;;   (make-face 'message-addresses)
  76. ;;   (or (face-differs-from-default-p 'message-addresses)
  77. ;;       (progn
  78. ;;     (copy-face 'bold-italic 'message-addresses)
  79. ;;     (set-face-underline-p 'message-addresses
  80. ;;                   (face-underline-p
  81. ;;                'message-highlighted-header-contents))))))
  82.  
  83. (defcustom highlight-headers-regexp "Subject[ \t]*:"
  84.   "*The headers whose contents should be emphasized more.
  85. The contents of these headers will be displayed in the face 
  86. `message-highlighted-header-contents' instead of `message-header-contents'."
  87.   :type 'regexp
  88.   :group 'highlight-headers)
  89.  
  90. (defcustom highlight-headers-citation-regexp
  91.   (concat "^\\("
  92.       (mapconcat 'identity
  93.        '("[ \t]*[a-zA-Z0-9_]+>+"    ; supercite
  94.          "[ \t]*[>]+"        ; ">" with leading spaces
  95.          "[]}<>|:]+[ \t]*"        ; other chars, no leading space
  96.          )
  97.        "\\|")
  98.       "\\)[ \t]*")
  99.   "*The pattern to match cited text.
  100. Text in the body of a message which matches this will be displayed in
  101. the face `message-cited-text'."
  102.   :type 'regexp
  103.   :group 'highlight-headers)
  104.  
  105. (defcustom highlight-headers-citation-header-regexp
  106.   (concat "^In article\\|^In message\\|"
  107.       "^[^ \t].*\\(writes\\|wrote\\|said\\):\n"
  108.       (substring highlight-headers-citation-regexp 1))
  109.   "*The pattern to match the prolog of a cited block.
  110. Text in the body of a message which matches this will be displayed in
  111. the `message-headers' face."
  112.   :type 'regexp
  113.   :group 'highlight-headers)
  114.  
  115. (defcustom highlight-headers-highlight-citation-too nil
  116.   "*Whether the whole citation line should go in the `message-cited-text' face.
  117. If nil, the text matched by `highlight-headers-citation-regexp' is in the
  118. default face, and the remainder of the line is in the message-cited-text face."
  119.   :type 'boolean
  120.   :group 'highlight-headers)
  121.  
  122. (defcustom highlight-headers-max-message-size 10000
  123.   "*If the message body is larger than this many chars, don't highlight it.
  124. This is to prevent us from wasting time trying to fontify things like
  125. uuencoded files and large digests.  If this is nil, all messages will
  126. be highlighted."
  127.   :type '(choice integer
  128.          (const :tag "Highlight All" nil))
  129.   :group 'highlight-headers)
  130.  
  131. (defcustom highlight-headers-hack-x-face-p (featurep 'xface)
  132.   "*If true, then the bitmap in an X-Face header will be displayed
  133. in the buffer.  This assumes you have the `uncompface' and `icontopbm'
  134. programs on your path."
  135.   :type 'boolean
  136.   :group 'highlight-headers)
  137.  
  138. (defcustom highlight-headers-convert-quietly nil
  139.   "*Non-nil inhibits the message that is normally displayed when external
  140. filters are used to convert an X-Face header.  This has no effect if
  141. XEmacs is compiled with internal support for x-faces."
  142.   :type 'boolean
  143.   :group 'highlight-headers)
  144.  
  145. (defcustom highlight-headers-invert-x-face-data nil 
  146.   "*If true, causes the foreground and background bits in an X-Face
  147. header to be flipped before the image is displayed. If you use a
  148. light foreground color on a dark background color, you probably want
  149. to set this to t. This assumes that you have the `pnminvert' program
  150. on your path.  This doesn't presently work with internal xface support."
  151.   :type 'boolean
  152.   :group 'highlight-headers)
  153.  
  154.  
  155. ;;;###autoload
  156. (defun highlight-headers (start end hack-sig)
  157.   "Highlight message headers between start and end.
  158. Faces used:
  159.   message-headers            the part before the colon
  160.   message-header-contents        the part after the colon
  161.   message-highlighted-header-contents    contents of \"special\" headers
  162.   message-cited-text            quoted text from other messages
  163.  
  164. Variables used:
  165.  
  166.   highlight-headers-regexp            what makes a \"special\" header
  167.   highlight-headers-citation-regexp        matches lines of quoted text
  168.   highlight-headers-citation-header-regexp    matches headers for quoted text
  169.  
  170. If HACK-SIG is true,then we search backward from END for something that
  171. looks like the beginning of a signature block, and don't consider that a
  172. part of the message (this is because signatures are often incorrectly
  173. interpreted as cited text.)"
  174.   (if (< end start)
  175.       (let ((s start)) (setq start end end s)))
  176.   (let* ((too-big (and highlight-headers-max-message-size
  177.                (> (- end start)
  178.               highlight-headers-max-message-size)))
  179.      (real-end end)
  180.      e p hend)
  181.     ;; delete previous highlighting
  182.     (map-extents (function (lambda (extent ignore)
  183.                  (if (extent-property extent 'headers)
  184.                  (delete-extent extent))
  185.                  nil))
  186.          (current-buffer) start end)
  187.     (save-excursion
  188.       (save-restriction
  189.     (widen)
  190.     ;; take off signature
  191.     (if (and hack-sig (not too-big))
  192.         (save-excursion
  193.           (goto-char end)
  194.           (if (re-search-backward "\n--+ *\n" start t)
  195.           (if (eq (char-after (point)) ?\n)
  196.               (setq end (1+ (point)))
  197.             (setq end (point))))))
  198.     (narrow-to-region start end)
  199.  
  200.     (save-restriction
  201.       ;; narrow down to just the headers...
  202.       (goto-char start)
  203.       ;; If this search fails then the narrowing performed above
  204.       ;; is sufficient
  205.       (if (re-search-forward "^$" nil t)
  206.           (narrow-to-region (point-min) (point)))
  207.       (goto-char start)
  208.       (while (not (eobp))
  209.         (cond
  210.          ((looking-at "^\\([^ \t\n:]+[ \t]*:\\) *\\(.*\\(\n[ \t].*\\)*\n\\)")
  211.           (setq hend (match-end 0))
  212.           (setq e (make-extent (match-beginning 1) (match-end 1)))
  213.           (set-extent-face e 'message-headers)
  214.           (set-extent-property e 'headers t)
  215.           (setq p (match-end 1))
  216.           (cond
  217.            ((and highlight-headers-hack-x-face-p
  218.              (save-match-data (looking-at "^X-Face: *")))
  219.         ;; make the whole header invisible
  220.         (setq e (make-extent (match-beginning 0) (match-end 0)))
  221.         (set-extent-property e 'invisible t)
  222.         (set-extent-property e 'headers t)
  223.         ;; now extract the xface and put it somewhere interesting
  224.         (let ((xface (highlight-headers-x-face-to-pixmap
  225.                   (match-beginning 2)
  226.                   (match-end 2))))
  227.           (if (not xface)
  228.               nil        ; just leave the header invisible if
  229.                     ; we can't convert the face for some
  230.                     ; reason 
  231.             (cond ((save-excursion
  232.                  (goto-char (point-min))
  233.                  (save-excursion (re-search-forward "^From: *"
  234.                                 nil t)))
  235.                (setq e (make-extent (match-end 0)
  236.                         (match-end 0))))
  237.               (t
  238.                ;; okay, make the beginning of the invisible
  239.                ;; move forward to only hide the modem noise...
  240.                (set-extent-endpoints e
  241.                          (match-beginning 2)
  242.                          (1- (match-end 2)))
  243.                ;; kludge: if a zero-length extent exists at the
  244.                ;; starting point of an invisible extent, then
  245.                ;; it's invisible... even if the invisible extent
  246.                ;; is start-open.  
  247.                (setq e (make-extent (1- (match-beginning 2))
  248.                         (match-beginning 2)))
  249.                ))
  250.             (set-extent-property e 'headers t)
  251.             (set-extent-end-glyph e xface))
  252.           ))
  253. ;;; I don't think this is worth the effort
  254. ;;;           ((looking-at "\\(From\\|Resent-From\\)[ \t]*:")
  255. ;;;            (setq current 'message-highlighted-header-contents)
  256. ;;;            (goto-char (match-end 0))
  257. ;;;            (or (looking-at ".*(\\(.*\\))")
  258. ;;;                (looking-at "\\(.*\\)<")
  259. ;;;                (looking-at "\\(.*\\)[@%]")
  260. ;;;                (looking-at "\\(.*\\)"))
  261. ;;;            (end-of-line)
  262. ;;;            (setq e (make-extent p (match-beginning 1)))
  263. ;;;            (set-extent-face e current)
  264. ;;;            (set-extent-property e 'headers t)
  265. ;;;            (setq e (make-extent (match-beginning 1) (match-end 1)))
  266. ;;;            (set-extent-face e 'message-addresses)
  267. ;;;            (set-extent-property e 'headers t)
  268. ;;;            (setq e (make-extent (match-end 1) (point)))
  269. ;;;            (set-extent-face e current)
  270. ;;;            (set-extent-property e 'headers t)
  271. ;;;            )
  272.            ((and highlight-headers-regexp
  273.              (save-match-data (looking-at highlight-headers-regexp)))
  274.         (setq e (make-extent (match-beginning 2) (match-end 2)))
  275.         (set-extent-face e 'message-highlighted-header-contents)
  276.         (set-extent-property e 'headers t))
  277.            (t
  278.         (setq e (make-extent (match-beginning 2) (match-end 2)))
  279.         (set-extent-face e 'message-header-contents)
  280.         (set-extent-property e 'headers t))
  281.             )
  282.            (goto-char hend))
  283.           ;; ignore non-header field name lines
  284.           (t (forward-line 1)))))
  285.  
  286.     ;; now do the body, unless it's too big....
  287.     (if too-big
  288.         nil
  289.       (while (not (eobp))
  290.         (cond ((null highlight-headers-citation-regexp)
  291.            nil)
  292.           ((looking-at highlight-headers-citation-regexp)
  293.            (or highlight-headers-highlight-citation-too
  294.                (goto-char (match-end 0)))
  295.            (or (save-excursion
  296.              (beginning-of-line)
  297.              (let ((case-fold-search nil)) ; aaaaah, unix...
  298.                (looking-at "^>From ")))
  299.                (setq current 'message-cited-text)))
  300. ;;;                ((or (looking-at "^In article\\|^In message")
  301. ;;;                     (looking-at
  302. ;;;            "^[^ \t].*\\(writes\\|wrote\\|said\\):\n[ \t]+[A-Z]*[]}<>|]"))
  303. ;;;                 (setq current 'message-headers))
  304.           ((null highlight-headers-citation-header-regexp)
  305.            nil)
  306.           ((looking-at highlight-headers-citation-header-regexp)
  307.            (setq current 'message-headers))
  308.           (t (setq current nil)))
  309.         (cond (current
  310.            (setq p (point))
  311.            (forward-line 1) ; this is to put the \n in the face too
  312.            (setq e (make-extent p (point)))
  313.            (forward-char -1)
  314.            (set-extent-face e current)
  315.            (set-extent-property e 'headers t)
  316.            ))
  317.         (forward-line 1)))
  318.     ))
  319.     (save-excursion
  320.       (save-restriction
  321.     (widen)
  322.     (narrow-to-region start real-end)
  323.     (highlight-headers-mark-urls start real-end)))
  324.     ))
  325.  
  326.  
  327. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  328. ;;;
  329. ;;; X-Face header conversion:
  330.  
  331. ;;; This cache is only used if x-face conversion is done with external
  332. ;;; filters.  If XEmacs is compiled --with-xface, then it's better to
  333. ;;; convert it twice than to suck up memory for a potentially large cache of
  334. ;;; stuff that's not difficult to recreate.
  335. (defvar highlight-headers-x-face-to-pixmap-cache nil)
  336.  
  337. (defun highlight-headers-x-face-to-pixmap (start end)
  338.   (let* ((string (if (stringp start) start (buffer-substring start end)))
  339.      (data (assoc string highlight-headers-x-face-to-pixmap-cache)))
  340.     (if (featurep 'xface)
  341.     (let ((new-face (make-glyph (concat "X-Face: " string))))
  342.       (set-glyph-face new-face 'x-face)
  343.       new-face)
  344.       ;; YUCK this is the old two-external-filters-plus-a-bunch-of-lisp method
  345.       (if data
  346.       (cdr data)
  347.     (setq data (cons string
  348.              (condition-case c
  349.                  (highlight-headers-parse-x-face-data start end)
  350.                (error
  351.                 (display-error c nil)
  352.                 (sit-for 2)
  353.                 nil))))
  354.     (setq highlight-headers-x-face-to-pixmap-cache
  355.           (cons data highlight-headers-x-face-to-pixmap-cache))
  356.     (cdr data)))
  357.     ))
  358.  
  359. ;;; Kludge kludge kludge for displaying the bitmap in the X-Face header.
  360.  
  361. ;;; This depends on the following programs: icontopbm, from the pbmplus
  362. ;;; toolkit (available everywhere) and uncompface, which comes with
  363. ;;; several faces-related packages, and can also be had at ftp.clark.net
  364. ;;; in /pub/liebman/compface.tar.Z.  See also xfaces 3.*.  Not needed
  365. ;;; for this, but a very nice xbiff replacment.
  366.  
  367. (defconst highlight-headers-x-face-bitrev
  368.   (purecopy
  369.    (eval-when-compile
  370.      (let* ((v (make-string 256 0))
  371.         (i (1- (length v))))
  372.        (while (>= i 0)
  373.      (let ((j 7)
  374.            (k 0))
  375.        (while (>= j 0)
  376.          (if (/= 0 (logand i (lsh 1 (- 7 j))))
  377.          (setq k (logior k (lsh 1 j))))
  378.          (setq j (1- j)))
  379.        (aset v i k))
  380.      (setq i (1- i)))
  381.        v))))
  382.  
  383. (defun highlight-headers-parse-x-face-data (start end)
  384.   (save-excursion
  385.     (let ((b (current-buffer))
  386.       (lines 0)
  387.       p)
  388.       (or highlight-headers-convert-quietly
  389.       (message "Converting X-Face header to pixmap ..."))
  390.       (set-buffer (get-buffer-create " *x-face-tmp*"))
  391.       (buffer-disable-undo (current-buffer))
  392.       (erase-buffer)
  393.       (if (stringp start)
  394.       (insert start)
  395.     (insert-buffer-substring b start end))
  396.       (while (search-forward "\n" nil t)
  397.     (skip-chars-backward " \t\n")
  398.     (setq p (point))
  399.     (skip-chars-forward " \t\n")
  400.     (delete-region p (point)))
  401.       (call-process-region (point-min) (point-max) "uncompface" t t nil)
  402.       (goto-char (point-min))
  403.       (while (not (eobp))
  404.     (or (looking-at "0x....,0x....,0x...., *$")
  405.         (error "unexpected uncompface output"))
  406.     (forward-line 1)
  407.     (setq lines (1+ lines))
  408.     (delete-char -1))
  409.       (goto-char (point-min))
  410.       (insert (format "/* Format_version=1, Width=%d, Height=%d" lines lines))
  411.       (insert ", Depth=1, Valid_bits_per_item=16\n */\n")
  412.       (while (not (eobp))
  413.     (insert ?\t)
  414.     (forward-char 56) ; 7 groups per line
  415.     (insert ?\n))
  416.       (forward-char -1)
  417.       (delete-char -1)  ; take off last comma
  418.       ;;
  419.       ;; Ok, now we've got the format that "icontopbm" knows about.
  420.       (call-process-region (point-min) (point-max) "icontopbm" t t nil)
  421.       ;; Invert the image if the user wants us to...
  422.       (if highlight-headers-invert-x-face-data
  423.       (call-process-region (point-min) (point-max) "pnminvert" t t nil))
  424.       ;;
  425.       ;; If PBM is using binary mode, we're winning.
  426.       (goto-char (point-min))
  427.       (let ((new-face))
  428.     (cond ((looking-at "P4\n")
  429.            (forward-line 2)
  430.            (delete-region (point-min) (point))
  431.            (while (not (eobp))
  432.          (insert (aref highlight-headers-x-face-bitrev
  433.                    (following-char)))
  434.          (delete-char 1))
  435.            (setq new-face (make-glyph
  436.                    (vector 'xbm :data
  437.                        (list lines lines (prog1 (buffer-string)
  438.                                (erase-buffer))))))
  439.            (set-glyph-image new-face "[xface]" 'global 'tty)
  440.            (set-glyph-face new-face 'x-face))
  441.           (t ; fix me
  442.            (error "I only understand binary-format PBM...")))
  443.     (or highlight-headers-convert-quietly
  444.         (message "Converting X-Face header to pixmap ... done."))
  445.     new-face)
  446.       )))
  447.  
  448.  
  449. ;;; "The Internet's new BBS!" -Boardwatch Magazine
  450. ;;; URL support by jwz@netscape.com
  451.  
  452. (defcustom highlight-headers-mark-urls (string-match "XEmacs" emacs-version)
  453.   "*Whether to make URLs clickable in message bodies."
  454.   :type 'boolean
  455.   :group 'highlight-headers)
  456.  
  457. ;; Uh, these should really use browse-url.  They are too lame to be
  458. ;; customized.
  459.  
  460. (defvar highlight-headers-follow-url-function 'w3-fetch
  461.   "The function to invoke to follow a URL.
  462. Possible values that work out of the box are:
  463.  
  464. 'w3-fetch                                == Use emacs-w3
  465. 'highlight-headers-follow-url-netscape   == Use Netscape
  466. 'highlight-headers-follow-url-mosaic     == Use Mosaic")
  467.  
  468. (defvar highlight-headers-follow-url-netscape-auto-raise t
  469.   "*Whether to make Netscape auto-raise when a URL is sent to it.")
  470.  
  471. (defvar highlight-headers-follow-url-netscape-new-window nil
  472.   "*Whether to make Netscape create a new window when a URL is sent to it.")
  473.  
  474. ;;;###autoload
  475. (defun highlight-headers-follow-url-netscape (url)
  476.   (message "Sending URL to Netscape...")
  477.   (save-excursion
  478.     (set-buffer (get-buffer-create "*Shell Command Output*"))
  479.     (erase-buffer)
  480.     (if (equal
  481.      0
  482.      (apply 'call-process "netscape" nil t nil
  483.         (nconc
  484.          (and (not highlight-headers-follow-url-netscape-auto-raise)
  485.               (list "-noraise"))
  486.          (list
  487.           "-remote"
  488.           (concat "openURL(" url
  489.               (if highlight-headers-follow-url-netscape-new-window
  490.                   ",new-window)" ")"))))))
  491.     ;; it worked
  492.     nil
  493.       ;; it didn't work, so start a new Netscape process.
  494.       (call-process "netscape" nil 0 nil url)))
  495.   (message "Sending URL to Netscape... done"))
  496.  
  497. ;;;###autoload
  498. (defun highlight-headers-follow-url-mosaic (url)
  499.   (message "Sending URL to Mosaic...")
  500.   (let ((pid-file "~/.mosaicpid")
  501.     (work-buffer " *mosaic work*")
  502.     (pid nil))
  503.     (cond ((file-readable-p pid-file)
  504.        (set-buffer (get-buffer-create work-buffer))
  505.        (erase-buffer)
  506.        (insert-file-contents pid-file)
  507.        (setq pid (int-to-string (string-to-int (buffer-string))))
  508.        (erase-buffer)
  509.        (insert "goto" ?\n)
  510.        (insert url ?\n)
  511.        (write-region (point-min) (point-max)
  512.              (concat "/tmp/Mosaic." pid)
  513.              nil 0)
  514.        (set-buffer-modified-p nil)
  515.        (kill-buffer work-buffer)))
  516.     (cond ((or (null pid)
  517.            (not (equal 0 (call-process "kill" nil nil nil "-USR1" pid))))
  518.        (call-process "Mosaic" nil 0 nil url))))
  519.   (message "Sending URL to Mosaic... done"))
  520.  
  521. (defvar highlight-headers-url-keymap
  522.   (let ((m (make-sparse-keymap)))
  523.     (set-keymap-name m 'highlight-headers-url-keymap)
  524.     (if (string-match "XEmacs" emacs-version)
  525.     (progn
  526.       (define-key m 'button2 'highlight-headers-follow-url)
  527.       ))
  528.     m))
  529.  
  530. ;;;###autoload
  531. (defun highlight-headers-follow-url (event)
  532.   (interactive "e")
  533.   (let* ((p (event-point event))
  534.      (buffer (window-buffer (event-window event)))
  535.      (extent (and p (extent-at p buffer 'highlight)))
  536.      (url (and extent
  537.            (save-excursion
  538.              (set-buffer buffer)
  539.              (buffer-substring (extent-start-position extent)
  540.                        (extent-end-position extent))))))
  541.     (if (and url (string-match "\\`<\\([^>]+\\)>\\'" url))
  542.     (setq url (concat "news:"
  543.               (substring url (match-beginning 1) (match-end 1)))))
  544.     (if url
  545.     (funcall highlight-headers-follow-url-function url)
  546.       (beep))))
  547.  
  548.  
  549. (defconst highlight-headers-url-pattern
  550.   (concat
  551.    "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|s?news\\|telnet\\|mailbox\\):"
  552.       "\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?"
  553.       "[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]+"
  554.       ))
  555.  
  556. (defun highlight-headers-mark-urls (start end)
  557.   (cond
  558.    (highlight-headers-mark-urls
  559.     (save-excursion
  560.       (goto-char start)
  561.       (while (re-search-forward highlight-headers-url-pattern nil t)
  562.     (let ((s (match-beginning 0))
  563.           e
  564.           extent)
  565.       (goto-char (match-end 0))
  566.       ;(skip-chars-forward "^ \t\n\r")
  567.       (skip-chars-backward ".?#!*()")
  568.       (setq e (point))
  569.       (setq extent (make-extent s e))
  570.       (set-extent-face extent 'bold)
  571.       (set-extent-property extent 'highlight t)
  572.       (set-extent-property extent 'headers t)
  573.       (set-extent-property extent 'keymap highlight-headers-url-keymap)
  574.       ))
  575.  
  576.       (goto-char start)
  577.       (while (re-search-forward "^Message-ID: \\(<[^>\n]+>\\)" nil t)
  578.     (let ((s (match-beginning 1))
  579.           (e (match-end 1))
  580.           extent)
  581.       (setq extent (make-extent s e))
  582.       (set-extent-face extent 'bold)
  583.       (set-extent-property extent 'highlight t)
  584.       (set-extent-property extent 'headers t)
  585.       (set-extent-property extent 'keymap highlight-headers-url-keymap)))
  586.       ))))
  587.  
  588.  
  589. (provide 'highlight-headers)
  590.